home *** CD-ROM | disk | FTP | other *** search
/ Complete Internet Archive / Complete Internet Archive.iso / VRML / cp2b2x.exe / DATA.Z / console.tcl < prev    next >
Encoding:
Text File  |  1996-04-23  |  7.9 KB  |  344 lines
  1. # console.tcl --
  2. #
  3. # This code constructs the console window for an application.  It
  4. # can be used by non-unix systems that do not have built-in support
  5. # for shells.
  6. #
  7. # @(#) console.tcl 1.16 95/10/03 22:14:30
  8. #
  9. # Copyright (c) 1995 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. # TODO: fix history - last event skiped - change history command
  16. #    or use "history event [expr [history nextid] - 1]]"
  17. # TODO: history - remember partially written command
  18. # TODO: get better default size for console -
  19. #       auto configure based on font size???
  20.  
  21. # tkConsoleInit --
  22. # This procedure constructs and configures the console windows.
  23. #
  24. # Arguments:
  25. #     None.
  26.  
  27. proc tkConsoleInit {} {
  28.     global tcl_platform
  29.  
  30.     text .console  -yscrollcommand ".sb set" -setgrid true
  31.     scrollbar .sb -command ".console yview"
  32.     pack .sb -side right -fill both
  33.     pack .console -fill both -expand 1 -side left
  34.     if {$tcl_platform(platform) == "macintosh"} {
  35.         after idle {.console configure -font {Monaco 9 normal}}
  36.     }
  37.  
  38.     tkConsoleBind .console
  39.  
  40.     .console tag configure stderr -foreground red
  41.     .console tag configure stdout -foreground black
  42.     .console tag configure stdin -foreground blue
  43.  
  44.     focus .console
  45.     
  46.     wm protocol . WM_DELETE_WINDOW { wm withdraw . }
  47.     tkConsolePrompt
  48. }
  49.  
  50. # tkConsoleInvoke --
  51. # Processes the command line input.  If the command is complete it
  52. # is evaled in the main interpreter.  Otherwise, the continuation
  53. # prompt is added and more input may be added.
  54. #
  55. # Arguments:
  56. # None.
  57.  
  58. proc tkConsoleInvoke {args} {
  59.     set ranges [.console tag ranges input]
  60.     set cmd ""
  61.     if {$ranges != ""} {
  62.     set pos 0
  63.     while {[lindex $ranges $pos] != ""} {
  64.         set start [lindex $ranges $pos]
  65.         set end [lindex $ranges [incr pos]]
  66.         append cmd [.console get $start $end]
  67.         incr pos
  68.     }
  69.     }
  70.     if {$cmd == ""} {
  71.     tkConsolePrompt
  72.     } elseif [info complete $cmd] {
  73.     .console mark set output end
  74.     .console tag delete input
  75.     set result [interp record $cmd]
  76.     if {$result != ""} {
  77.         .console insert insert "$result\n"
  78.     }
  79.     tkConsoleHistory reset
  80.     tkConsolePrompt
  81.     } else {
  82.     tkConsolePrompt partial
  83.     }
  84.     .console yview -pickplace insert
  85. }
  86.  
  87. # tkConsoleHistory --
  88. # This procedure implements command line history for the
  89. # console.  In general is evals the history command in the
  90. # main interpreter to obtain the history.  The global variable
  91. # histNum is used to store the current location in the history.
  92. #
  93. # Arguments:
  94. # cmd -    Which action to take: prev, next, reset.
  95.  
  96. set histNum 1
  97. proc tkConsoleHistory {cmd} {
  98.     global histNum
  99.     
  100.     switch $cmd {
  101.         prev {
  102.         incr histNum -1
  103.         if {$histNum == 0} {
  104.         set cmd {history event [expr [history nextid] -1]}
  105.         } else {
  106.         set cmd "history event $histNum"
  107.         }
  108.             if {[catch {interp eval $cmd} cmd]} {
  109.                 incr histNum
  110.                 return
  111.             }
  112.         .console delete promptEnd end
  113.             .console insert promptEnd $cmd {input stdin}
  114.         }
  115.         next {
  116.         incr histNum
  117.         if {$histNum == 0} {
  118.         set cmd {history event [expr [history nextid] -1]}
  119.         } elseif {$histNum > 0} {
  120.         set cmd ""
  121.         set histNum 1
  122.         } else {
  123.         set cmd "history event $histNum"
  124.         }
  125.         if {$cmd != ""} {
  126.         catch {interp eval $cmd} cmd
  127.         }
  128.         .console delete promptEnd end
  129.         .console insert promptEnd $cmd {input stdin}
  130.         }
  131.         reset {
  132.             set histNum 1
  133.         }
  134.     }
  135. }
  136.  
  137. # tkConsolePrompt --
  138. # This procedure draws the prompt.  If tcl_prompt1 or tcl_prompt2
  139. # exists in the main interpreter it will be called to generate the 
  140. # prompt.  Otherwise, a hard coded default prompt is printed.
  141. #
  142. # Arguments:
  143. # partial -    Flag to specify which prompt to print.
  144.  
  145. proc tkConsolePrompt {{partial normal}} {
  146.     if {$partial == "normal"} {
  147.     set temp [.console index "end - 1 char"]
  148.     .console mark set output end
  149.         if [interp eval "info exists tcl_prompt1"] {
  150.             interp eval "eval \[set tcl_prompt1\]"
  151.         } else {
  152.             puts -nonewline "tcl> "
  153.         }
  154.     } else {
  155.     set temp [.console index output]
  156.     .console mark set output end
  157.         if [interp eval "info exists tcl_prompt2"] {
  158.             interp eval "eval \[set tcl_prompt2\]"
  159.         } else {
  160.         puts -nonewline "> "
  161.         }
  162.     }
  163.     .console mark set output $temp
  164.     tkTextSetCursor .console end
  165.     .console mark set promptEnd insert
  166.     .console mark gravity promptEnd left
  167. }
  168.  
  169. # tkConsoleBind --
  170. # This procedure first ensures that the default bindings for the Text
  171. # class have been defined.  Then certain bindings are overridden for
  172. # the class.
  173. #
  174. # Arguments:
  175. # None.
  176.  
  177. proc tkConsoleBind {win} {
  178.     catch {tkTextBind dummy_arg}
  179.     
  180.     bindtags $win "$win Text . all"
  181.  
  182.     bind $win <Return> {
  183.     %W mark set insert {end - 1c}
  184.     tkTextInsert %W "\n"
  185.     tkConsoleInvoke
  186.     break
  187.     }
  188.     bind $win <Delete> {
  189.     if {[%W tag nextrange sel 1.0 end] != ""} {
  190.         %W tag remove sel sel.first promptEnd
  191.     } else {
  192.         if [%W compare insert < promptEnd] {
  193.         break
  194.         }
  195.     }
  196.     }
  197.     bind $win <BackSpace> {
  198.     if {[%W tag nextrange sel 1.0 end] != ""} {
  199.         %W tag remove sel sel.first promptEnd
  200.     } else {
  201.         if [%W compare insert <= promptEnd] {
  202.         break
  203.         }
  204.     }
  205.     }
  206.     bind $win <Control-a> {
  207.     if [%W compare insert < promptEnd] {
  208.         tkTextSetCursor %W {insert linestart}
  209.     } else {
  210.         tkTextSetCursor %W promptEnd
  211.         }
  212.     break
  213.     }
  214.     bind $win <Control-d> {
  215.     if [%W compare insert < promptEnd] {
  216.         break
  217.     }
  218.     }
  219.     bind $win <Control-k> {
  220.     if [%W compare insert < promptEnd] {
  221.         %W mark set insert promptEnd
  222.     }
  223.     }
  224.     bind $win <Control-t> {
  225.     if [%W compare insert < promptEnd] {
  226.         break
  227.     }
  228.     }
  229.     bind $win <Meta-d> {
  230.     if [%W compare insert < promptEnd] {
  231.         break
  232.     }
  233.     }
  234.     bind $win <Meta-BackSpace> {
  235.     if [%W compare insert <= promptEnd] {
  236.         break
  237.     }
  238.     }
  239.     bind $win <Control-h> {
  240.     if [%W compare insert <= promptEnd] {
  241.         break
  242.     }
  243.     }
  244.     bind $win <Control-p> {
  245.     tkConsoleHistory prev
  246.     break
  247.     }
  248.     bind $win <Control-n> {
  249.     tkConsoleHistory next
  250.     break
  251.     }
  252.     bind $win <Control-v> {
  253.     if [%W compare insert > promptEnd] {
  254.         catch {
  255.         %W insert insert [selection get -displayof %W] {input stdin}
  256.         %W see insert
  257.         }
  258.     }
  259.     break
  260.     }
  261.     bind $win <F9> {
  262.     eval destroy [winfo child .]
  263.     source $tk_library/console.tcl
  264.     }
  265.     foreach copy {F16 Meta-w Control-i} {
  266.     bind Text <$copy> {
  267.         if {[selection own -displayof %W] == "%W"} {
  268.         clipboard clear -displayof %W
  269.         catch {
  270.             clipboard append -displayof %W [selection get -displayof %W]
  271.         }
  272.         }
  273.         break
  274.     }
  275.     }
  276.     foreach paste {F18 Control-y} {
  277.     bind $win <$paste> {
  278.         catch {
  279.             set clip [selection get -displayof %W -selection CLIPBOARD]
  280.         set list [split $clip \n\r]
  281.         tkTextInsert %W [lindex $list 0]
  282.         foreach x [lrange $list 1 end] {
  283.             %W mark set insert {end - 1c}
  284.             tkTextInsert %W "\n"
  285.             tkConsoleInvoke
  286.             tkTextInsert %W $x
  287.         }
  288.         }
  289.         break
  290.     }
  291.     }
  292. }
  293.  
  294. # Replace the default implementation of tkTextInsert so that we can
  295. # attach tags to user input
  296.  
  297. proc tkTextInsert {w s} {
  298.     if {$s == ""} {
  299.     return
  300.     }
  301.     catch {
  302.     if {[$w compare sel.first <= insert]
  303.         && [$w compare sel.last >= insert]} {
  304.         $w tag remove sel sel.first promptEnd
  305.         $w delete sel.first sel.last
  306.     }
  307.     }
  308.     if {[$w compare insert < promptEnd]} {
  309.     $w mark set insert end    
  310.     }
  311.     $w insert insert $s {input stdin}
  312.     $w see insert
  313. }
  314.  
  315. # tkConsoleOutput --
  316. #
  317. # This routine is called directly by ConsolePutsCmd to cause a string
  318. # to be displayed in the console.
  319. #
  320. # Arguments:
  321. # dest -    The output tag to be used: either "stderr" or "stdout".
  322. # string -    The string to be displayed.
  323.  
  324. proc tkConsoleOutput {dest string} {
  325.     .console insert output $string $dest
  326.     .console see insert
  327. }
  328.  
  329. # tkConsoleExit --
  330. #
  331. # This routine is called by ConsoleEventProc when the main window of
  332. # the application is destroyed.
  333. #
  334. # Arguments:
  335. # None.
  336.  
  337. proc tkConsoleExit {} {
  338.     exit
  339. }
  340.  
  341. # now initialize the console
  342.  
  343. tkConsoleInit
  344.